
SEGMENT PROCEDURE USERPROGRAM;
BEGIN END;

SEGMENT PROCEDURE COMPILER;
  SEGMENT PROCEDURE COMPINIT;
  BEGIN END;
BEGIN END;

SEGMENT PROCEDURE EDITOR;
BEGIN END;

SEGMENT PROCEDURE FILEHANDLER;
  VAR GCH: CHAR; GDIR: DIRP; GINX: DIRRANGE;
      BADCOMMAND: BOOLEAN; GSEGS: INTEGER; GKIND: FILEKIND;
      GUNIT: UNITNUM; GBUF: WINDOWP; GBUFBLKS: INTEGER;
      SYMSAVED,CODESAVED: BOOLEAN; (*WORKFILE INFO...HANDY*)
      GVID: VID; GTID: TID; GS: STRING;
      GVIDTID: STRING[25]; GTITLE: STRING[39]; INSTRING: STRING[127];
      GFIB: FIB; MONTHS: ARRAY [0..15] OF STRING[3];

  PROCEDURE FILERINIT;
    TYPE ABLOCK = PACKED ARRAY [1..FBLKSIZE] OF CHAR;
    VAR ONEBLOCK: ^ABLOCK;
	GAPSIZE,QUITSIZE: INTEGER;
  BEGIN
    SYMSAVED := TRUE; CODESAVED := TRUE;
    WITH USERINFO DO
      BEGIN
	IF GOTSYM THEN SYMSAVED := SYMTID <> 'SYSTEM.WRK.TEXT';
	IF GOTCODE THEN CODESAVED := CODETID <> 'SYSTEM.WRK.CODE'
      END;
    MONTHS[ 0] := 'XXX'; (*LEAVE THIS LINE IN!*)
    MONTHS[ 1] := 'JAN'; MONTHS[ 2] := 'FEB'; MONTHS[ 3] := 'MAR';
    MONTHS[ 4] := 'APR'; MONTHS[ 5] := 'MAY'; MONTHS[ 6] := 'JUN';
    MONTHS[ 7] := 'JUL'; MONTHS[ 8] := 'AUG'; MONTHS[ 9] := 'SEP';
    MONTHS[10] := 'OCT'; MONTHS[11] := 'NOV'; MONTHS[12] := 'DEC'; 
    MONTHS[13] := 'BAD'; MONTHS[14] := 'BAD'; MONTHS[15] := 'BAD'; 
    BADCOMMAND := FALSE; FINIT(GFIB,NIL,-1);
    MARK(GBUF); GBUFBLKS := 0;
    QUITSIZE := SIZEOF(DIRECTORY)+SIZEOF(FIB)+1400;
    REPEAT
      NEW(ONEBLOCK); GBUFBLKS := GBUFBLKS+1;
      GAPSIZE := ORD(SYSCOM^.LASTMP)-ORD(ONEBLOCK)-FBLKSIZE
    UNTIL ((GAPSIZE > 0) AND (GAPSIZE < QUITSIZE))
	OR (GBUFBLKS = 63); (*PREVENT INTEGER OFLOW*)
  END (*FILERINIT*) ;

  FUNCTION CHECKRSLT(RSLT: INTEGER): BOOLEAN;
  BEGIN
    CHECKRSLT := RSLT = 0;
    CASE RSLT OF
      1:  WRITE(OUTPUT,'Hard parity (CRC) error');
      2:  WRITE(OUTPUT,'Illegal unit number');
      3:  WRITE(OUTPUT,'Illegal operation on unit');
      4:  WRITE(OUTPUT,'Undefined hardware error');
      5:  WRITE(OUTPUT,'Volume has gone off-line');
      6:  WRITE(OUTPUT,'File lost in directory');
      7:  WRITE(OUTPUT,'Illegal file name');
      8:  WRITE(OUTPUT,'Insufficient space on volume');
      9:  WRITE(OUTPUT,'No such volume on-line');
     10:  WRITE(OUTPUT,'No such file on volume');
     11:  WRITE(OUTPUT,'Duplicate directory entries');
     12:  WRITE(OUTPUT,'Filer bug!!  not closed file')
    END
  END (* CHECKRSLT *) ;

  FUNCTION GETTITLE(MSG: STRING): BOOLEAN;
    VAR I: INTEGER;
  BEGIN GETTITLE := FALSE; GVIDTID := ''; GTITLE := '';
    IF LENGTH(INSTRING) = 0 THEN
      BEGIN WRITE(OUTPUT,MSG);
	IF NOT SYSCOM^.MISCINFO.SLOWTERM THEN
	  WRITE(OUTPUT,' what file');
	WRITE(OUTPUT,'? '); READLN(INPUT,INSTRING)
      END;
    IF LENGTH(INSTRING) > 0 THEN
      BEGIN
	I := SCAN(LENGTH(INSTRING), = ',', INSTRING[1]);
	IF I < LENGTH(INSTRING) THEN
	  BEGIN
	    GTITLE := COPY(INSTRING,1,I);
	    DELETE(INSTRING,1,I+1)
	  END
	ELSE
	  BEGIN
	    GTITLE := INSTRING;
	    INSTRING := ''
	  END;
	IF SCANTITLE(GTITLE,GVID,GTID,GSEGS,GKIND) THEN
	  BEGIN GETTITLE := TRUE;
	    GVIDTID := CONCAT(GVID,':',GTID)
	  END
	ELSE
	  WRITE(OUTPUT,'Illegal file name')
      END
  END (* GETTITLE *) ;

  FUNCTION GETVOLUME(LOOKHARD: BOOLEAN): BOOLEAN;
    LABEL 1;
  BEGIN GETVOLUME := FALSE;
    WRITE(OUTPUT,GS); READLN(INPUT,GS);
    INSERT(':',GS,LENGTH(GS)+1);
    IF SCANTITLE(GS,GVID,GTID,GSEGS,GKIND) THEN
      BEGIN
	GUNIT := VOLSEARCH(GVID,LOOKHARD,GDIR);
	GETVOLUME := GUNIT > 0;
	IF GUNIT = 0 THEN
	  WRITE(OUTPUT,GVID,': is not on-line')
	ELSE
	  IF LOOKHARD AND NOT UNITABLE[GUNIT].UISBLKD THEN
	    BEGIN GETVOLUME := FALSE;
	      WRITE(OUTPUT,GVID,': does not have a directory')
	    END
      END
    ELSE
      WRITE(OUTPUT,'Illegal volume name')
  END (*GETVOLUME*) ;

  PROCEDURE WHATWORK;
  BEGIN
    WITH USERINFO DO
      BEGIN WRITELN(OUTPUT);
	IF GOTSYM OR GOTCODE THEN
	  BEGIN WRITE(OUTPUT,'Workfile is ');
	    IF LENGTH(WORKTID) > 0 THEN
	      WRITE(OUTPUT,WORKTID)
	    ELSE
	      WRITE(OUTPUT,'not named');
	    IF NOT (SYMSAVED AND CODESAVED) THEN
	      WRITE(OUTPUT,' (not saved)')
	  END
	ELSE
	  WRITE(OUTPUT,'No workfile')
      END
  END (*WHATWORK*) ;

  PROCEDURE NEWWORK(GIVEBLURB: BOOLEAN);
    LABEL 1;
  BEGIN
    WITH USERINFO DO
      BEGIN
	IF NOT (SYMSAVED AND CODESAVED) THEN
	  BEGIN
	    WRITE(OUTPUT,'Throw away current workfile? ');
	    IF GETCHAR(FALSE) <> 'Y' THEN GOTO 1;
	    IF NOT GIVEBLURB THEN WRITELN(OUTPUT)
	  END;
	IF NOT SYMSAVED THEN
	  BEGIN
	    GS := '*SYSTEM.WRK.TEXT';
	    FOPEN(GFIB,GS,TRUE,NIL);
	    FCLOSE(GFIB,CPURGE)
	  END;
	IF NOT CODESAVED THEN
	  BEGIN
	    GS := '*SYSTEM.WRK.CODE';
	    FOPEN(GFIB,GS,TRUE,NIL);
	    FCLOSE(GFIB,CPURGE)
	  END;
	SYMSAVED := TRUE; CODESAVED := TRUE;
	GOTSYM := FALSE; GOTCODE := FALSE;
	WORKTID := ''; SYMTID := ''; CODETID := '';
	IF GIVEBLURB THEN
	  BEGIN WRITELN(OUTPUT);
	    WRITE(OUTPUT,'Empty workfile created')
	  END
      END;
1:
  END (*NEWWORK*) ;

  PROCEDURE GETWORK;
  BEGIN
    NEWWORK(FALSE);
    WITH USERINFO DO
      IF NOT (GOTSYM OR GOTCODE) THEN
	IF GETTITLE('Get') THEN
	  IF (LENGTH(GTID) > 0) AND (LENGTH(GTID) <= TIDLENG-5) THEN
	    BEGIN
	      WORKVID := GVID; WORKTID := GTID;
	      SYMTID := CONCAT(GTID,'.TEXT'); SYMVID := GVID;
	      GVIDTID := CONCAT(SYMVID,':',SYMTID);
	      FOPEN(GFIB,GVIDTID,TRUE,NIL);
	      GOTSYM := GFIB.FISOPEN;
	      IF GOTSYM THEN FCLOSE(GFIB,CNORMAL)
	      ELSE SYMTID := '';
	      CODETID := CONCAT(GTID,'.CODE'); CODEVID := GVID;
	      GVIDTID := CONCAT(CODEVID,':',CODETID);
	      FOPEN(GFIB,GVIDTID,TRUE,NIL);
	      GOTCODE := GFIB.FISOPEN;
	      IF GOTCODE THEN FCLOSE(GFIB,CNORMAL)
	      ELSE CODETID := '';
	      IF GOTSYM THEN WRITE(OUTPUT,'Text ');
	      IF GOTSYM AND GOTCODE THEN
		WRITE(OUTPUT,'and ');
	      IF GOTCODE THEN WRITE(OUTPUT,'Code ');
	      IF NOT (GOTSYM OR GOTCODE) THEN
		BEGIN WORKTID := '';
		  WRITE(OUTPUT,'No ')
		END;
	      WRITE(OUTPUT,'file loaded')
	    END
	  ELSE
	    BEGIN WORKTID := '';
	      WRITE(OUTPUT,'Illegal workfile name')
	    END
  END (*GETWORK*) ;

  PROCEDURE SAVEWORK;
    LABEL 1;
    VAR GETNEWTID: BOOLEAN;
  BEGIN
    WITH USERINFO DO
      BEGIN
	IF SYMSAVED AND CODESAVED THEN
	  BEGIN WRITELN(OUTPUT);
	    IF GOTSYM OR GOTCODE THEN
	      WRITE(OUTPUT,'Workfile already saved')
	    ELSE
	      WRITE(OUTPUT,'No workfile to save');
	    GOTO 1
	  END;
	IF WORKVID <> SYVID THEN WORKTID := '';
	GETNEWTID := LENGTH(WORKTID) = 0;
	IF NOT GETNEWTID THEN
	  BEGIN
	    WRITE(OUTPUT,'Save as ',WORKTID,'? ');
	    GETNEWTID := GETCHAR(TRUE) <> 'Y';
	    WRITELN(OUTPUT)
	  END;
	IF GETNEWTID THEN
	  IF GETTITLE('Save as') THEN
	    BEGIN WORKVID := GVID; WORKTID := GTID END
	  ELSE GOTO 1;
	IF (LENGTH(WORKTID) = 0) OR (LENGTH(WORKTID) > TIDLENG-5) THEN
	  BEGIN WORKTID := '';
	    WRITE(OUTPUT,'Illegal workfile name');
	    GOTO 1
	  END;
	IF WORKVID <> SYVID THEN
	  BEGIN WORKTID := '';
	    WRITE(OUTPUT,'Must save on system disk for now');
	    GOTO 1
	  END;
	IF NOT SYMSAVED THEN
	  BEGIN
	    GTITLE := '*SYSTEM.WRK.TEXT';
	    FOPEN(GFIB,GTITLE,TRUE,NIL);
	    IF GFIB.FISOPEN THEN
	     WITH GFIB.FHEADER DO
	      BEGIN
		DACCESS.YEAR := 100;
		SYMTID := CONCAT(WORKTID,'.TEXT');
		DTID := SYMTID;
		FCLOSE(GFIB,CNORMAL)
	      END
	    ELSE
	      BEGIN GOTSYM := FALSE;
		WRITELN(OUTPUT,'Lost workfile!')
	      END;
	    SYMSAVED := TRUE;
	    WRITE(OUTPUT,'Text ');
	    IF NOT CODESAVED THEN
	      WRITE(OUTPUT,'and ')
	  END;
	IF NOT CODESAVED THEN
	  BEGIN
	    GTITLE := '*SYSTEM.WRK.CODE';
	    FOPEN(GFIB,GTITLE,TRUE,NIL);
	    IF GFIB.FISOPEN THEN
	     WITH GFIB.FHEADER DO
	      BEGIN
		DACCESS.YEAR := 100;
		CODETID := CONCAT(WORKTID,'.CODE');
		DTID := CODETID;
		FCLOSE(GFIB,CNORMAL)
	      END
	    ELSE
	      BEGIN GOTCODE := FALSE;
		WRITE(OUTPUT,'Lost workfile!')
	      END;
	    CODESAVED := TRUE;
	    WRITE(OUTPUT,'Code ')
	  END;
	WRITE(OUTPUT,'file saved')
      END;
1:
  END (*SAVEWORK*) ;

  PROCEDURE PREFIXER;
  BEGIN
    GS := 'Default prefix volume name? ';
    IF NOT GETVOLUME(TRUE) THEN WRITELN(OUTPUT);
    DKVID := GVID;
    WRITE(OUTPUT,'Default prefix is ',DKVID,':')
  END (*PREFIXER*) ;

  PROCEDURE CHANGER;
    VAR LFIB: FIB;
  BEGIN
    REPEAT
      IF GETTITLE('Change') THEN
	BEGIN FOPEN(GFIB,GVIDTID,TRUE,NIL);
	  IF CHECKRSLT(IORESULT) THEN
	    BEGIN
	      IF GETTITLE('To') THEN
		WITH GFIB DO
		  BEGIN FINIT(LFIB,NIL,-1);
		    IF FISBLKD AND (LENGTH(FHEADER.DTID) > 0) THEN
		      BEGIN GVID := FVID;
			GVIDTID := CONCAT(GVID,':',GTID)
		      END;
		    FOPEN(LFIB,GVIDTID,TRUE,NIL);
		    IF FISBLKD AND (LENGTH(FHEADER.DTID) > 0) THEN
		      IF LENGTH(GTID) = 0 THEN
			WRITE(OUTPUT,'Must specify both titles')
		      ELSE
			BEGIN
			  IF LFIB.FISOPEN THEN
			    BEGIN
			      WRITE(OUTPUT,GTID,' exists...remove it? ');
			      IF GETCHAR(TRUE) = 'Y' THEN
				BEGIN
				  FCLOSE(LFIB,CNORMAL);
				  WRITELN(OUTPUT)
				END
			    END;
			  IF NOT LFIB.FISOPEN THEN
			    BEGIN
			      WRITE(OUTPUT,FVID,':',FHEADER.DTID,
				  ' changed to ',GTID);
			      FHEADER.DTID := GTID;
			      FHEADER.DACCESS.YEAR := 100
			    END
			END
		    ELSE
		      IF LENGTH(GTID) > 0 THEN
			WRITE(OUTPUT,'No title may be specified')
		      ELSE
			IF LFIB.FISOPEN THEN
			  WRITE(OUTPUT,'No duplicate volume names')
			ELSE
			  BEGIN
			    UNITABLE[FUNIT].UVID := GVID;
			    IF FISBLKD THEN
			      BEGIN (*CHANGE VOLUME NAME IN DIR*)
				NEW(GDIR);
				UNITREAD(FUNIT,GDIR^,SIZEOF(DIRECTORY),DIRBLK);
				GDIR^[0].DVID := GVID;
				UNITWRITE(FUNIT,GDIR^,(GDIR^[0].DNUMFILES+1)
					*SIZEOF(DIRENTRY),DIRBLK);
				RELEASE(GDIR)
			      END;
			    WRITE(OUTPUT,FVID,': changed to ',GVID,':');
			    FVID := GVID
			  END;
		    FCLOSE(LFIB,CNORMAL)
		  END;
	      FCLOSE(GFIB,CNORMAL)
	    END
	END;
      IF LENGTH(INSTRING) > 0 THEN WRITELN(OUTPUT)
    UNTIL LENGTH(INSTRING) = 0
  END (*CHANGER*) ;

  PROCEDURE REMOVER;
  BEGIN
    REPEAT
      IF GETTITLE('Remove') THEN
	BEGIN FOPEN(GFIB,GTITLE,TRUE,NIL);
	  IF CHECKRSLT(IORESULT) THEN
	    BEGIN FCLOSE(GFIB,CPURGE);
	      IF CHECKRSLT(IORESULT) THEN
		WRITE(OUTPUT,GVIDTID,' removed')
	    END
	END;
      IF LENGTH(INSTRING) > 0 THEN WRITELN(OUTPUT)
    UNTIL LENGTH(INSTRING) = 0
  END (*REMOVER*) ;

  PROCEDURE TRANSFER;
    VAR NBLOCKS,RSLT: INTEGER;
	LFIB: FIB;
  BEGIN
    REPEAT
      IF GETTITLE('Transfer') THEN
	BEGIN FOPEN(GFIB,GTITLE,TRUE,NIL);
	  IF CHECKRSLT(IORESULT) THEN
	    BEGIN
	      NBLOCKS := FBLOCKIO(GFIB,GBUF^,GBUFBLKS,-1,TRUE);
	      IF CHECKRSLT(IORESULT) THEN
		IF GETTITLE('To') THEN
		  BEGIN FINIT(LFIB,NIL,-1);
		    FOPEN(LFIB,GTITLE,FALSE,NIL);
		    IF CHECKRSLT(IORESULT) THEN
		      BEGIN
			WHILE NBLOCKS > 0 DO
			  BEGIN
			    RSLT := FBLOCKIO(LFIB,GBUF^,NBLOCKS,
					      -1,FALSE);
			    IF RSLT = NBLOCKS THEN
			      IF GFIB.FEOF THEN NBLOCKS := 0
			      ELSE
				BEGIN
				  NBLOCKS := FBLOCKIO(GFIB,GBUF^,GBUFBLKS,
							-1,TRUE);
				  IF NOT CHECKRSLT(IORESULT) THEN
				    BEGIN NBLOCKS := 0;
				      FCLOSE(LFIB,CPURGE)
				    END
				END
			    ELSE
			      BEGIN NBLOCKS := 0;
				FCLOSE(LFIB,CPURGE);
				WRITE(OUTPUT,'Output file full')
			      END
			  END;
			IF LFIB.FISOPEN THEN
			  BEGIN
			    WRITE(OUTPUT,GFIB.FVID,':',GFIB.FHEADER.DTID,
				' transferred to ',LFIB.FVID,
				':',LFIB.FHEADER.DTID);
			    WITH LFIB,GFIB.FHEADER DO
			      BEGIN
				FHEADER.DLASTBYTE := DLASTBYTE;
				FHEADER.DFKIND := DFKIND;
				FHEADER.DACCESS := DACCESS;
				IF (DACCESS.MONTH = 0) AND
				   (THEDATE.MONTH > 0) THEN
				  FHEADER.DACCESS := THEDATE
			      END;
			    FCLOSE(LFIB,CLOCK)
			  END
		      END
		  END;
	      FCLOSE(GFIB,CNORMAL)
	    END
	END;
      IF LENGTH(INSTRING) > 0 THEN WRITELN(OUTPUT)
    UNTIL LENGTH(INSTRING) = 0
  END (*TRANSFER*) ;

  PROCEDURE MAKEFILE;
  BEGIN
    REPEAT
      IF GETTITLE('Make') THEN
	BEGIN FOPEN(GFIB,GTITLE,FALSE,NIL);
	  IF CHECKRSLT(IORESULT) THEN
	    BEGIN
	      WITH GFIB DO
		FMAXBLK := FHEADER.DLASTBLK-FHEADER.DFIRSTBLK;
	      FCLOSE(GFIB,CLOCK);
	      IF CHECKRSLT(IORESULT) THEN
		WRITE(OUTPUT,GVIDTID,' created')
	    END
	END;
      IF LENGTH(INSTRING) > 0 THEN WRITELN(OUTPUT)
    UNTIL LENGTH(INSTRING) = 0
  END (*MAKEFILE*) ;

  PROCEDURE LISTDIR(DETAIL: BOOLEAN);
    VAR I: DIRRANGE;
	LINE,LARGEST,FREEBLKS,USEDAREA,USEDBLKS: INTEGER;

    PROCEDURE WRITELINE;
    BEGIN
      IF LINE = SYSCOM^.CRTINFO.HEIGHT THEN
	BEGIN
	  IF SPACEWAIT THEN EXIT(LISTDIR);
	  CLEARSCREEN; LINE := 2;
	  WRITELN(OUTPUT);
	  WRITE(OUTPUT,GVID,':')
	END;
      LINE := LINE+1; WRITELN(OUTPUT)
    END (*WRITELINE*) ;

    PROCEDURE FREECHECK(FIRSTOPEN,NEXTUSED: INTEGER);
      VAR FREEAREA: INTEGER;
    BEGIN
      FREEAREA := NEXTUSED-FIRSTOPEN;
      IF FREEAREA > LARGEST THEN LARGEST := FREEAREA;
      IF FREEAREA > 0 THEN
	BEGIN FREEBLKS := FREEBLKS+FREEAREA;
	  IF DETAIL THEN
	    BEGIN
	      WRITE(OUTPUT,'< UNUSED >      ',
			FREEAREA:4,' ':11,FIRSTOPEN:6);
	      WRITELINE
	    END
	END;
    END (*FREECHECK*) ;

  BEGIN (*LISTDIR*)
    GS := 'Directory of what volume? ';
    IF GETVOLUME(TRUE) THEN
      BEGIN
	FREEBLKS := 0; USEDBLKS := 0;
	LARGEST := 0; LINE := 3;
	WRITELN(OUTPUT,GVID,':');
	FOR I := 1 TO GDIR^[0].DNUMFILES DO
	  WITH GDIR^[I] DO
	    BEGIN
	      FREECHECK(GDIR^[I-1].DLASTBLK,DFIRSTBLK);
	      USEDAREA := DLASTBLK-DFIRSTBLK;
	      USEDBLKS := USEDBLKS+USEDAREA;
	      WRITE(OUTPUT,DTID,' ':TIDLENG-LENGTH(DTID)+1,USEDAREA:4);
	      IF DACCESS.MONTH > 0 THEN
		WRITE(OUTPUT,' ':2,DACCESS.DAY:2,'-',
			MONTHS[DACCESS.MONTH],'-',DACCESS.YEAR:2);
	      IF DETAIL THEN
		BEGIN
		  IF DACCESS.MONTH = 0 THEN WRITE(OUTPUT,' ':11);
		  WRITE(OUTPUT,DFIRSTBLK:6,DLASTBYTE:6);
		  GS := 'ILLEGAL';
		  CASE DFKIND OF
		    XDSKFILE: GS := 'Bad disk';
		    CODEFILE: GS := 'Codefile';
		    TEXTFILE: GS := 'Textfile';
		    INFOFILE: GS := 'Infofile';
		    DATAFILE: GS := 'Datafile';
		    GRAFFILE: GS := 'Graffile';
		    FOTOFILE: GS := 'Fotofile'
		  END;
		  WRITE(OUTPUT,' ':2,GS)
		END;
	      WRITELINE
	    END;
	FREECHECK(GDIR^[I-1].DLASTBLK,GDIR^[0].DEOVBLK);
	WRITE(OUTPUT,GDIR^[0].DNUMFILES,' files, ',
			USEDBLKS,' blocks in use, ',
			FREEBLKS,' unused');
	IF DETAIL THEN
	  WRITE(OUTPUT,', ',LARGEST,' in largest area')
      END
  END (*LISTDIR*) ;

  PROCEDURE LISTVOLS;
  BEGIN
    WRITELN(OUTPUT,'Volumes currently on-line:');
    GVID := '';
    GUNIT := VOLSEARCH(GVID,TRUE,GDIR);
    FOR GUNIT := 1 TO MAXUNIT DO
     WITH UNITABLE[GUNIT] DO
      IF LENGTH(UVID) > 0 THEN
	BEGIN
	  WRITE(OUTPUT,GUNIT:3);
	  IF UVID = SYVID THEN WRITE(OUTPUT,' * ')
	  ELSE
	    IF UVID = DKVID THEN WRITE(OUTPUT,' P ')
	    ELSE
	      IF UISBLKD THEN WRITE(OUTPUT,' # ')
	      ELSE WRITE(OUTPUT,'   ');
	  WRITELN(OUTPUT,UVID,':')
	END
  END (*LISTVOLS*) ;

  PROCEDURE BADBLOCKS;
    VAR I: INTEGER;
	A: PACKED ARRAY [0..FBLKSIZE] OF CHAR;
  BEGIN
    GS := 'Bad blocks of what volume? ';
    IF GETVOLUME(TRUE) THEN
      FOR I := 0 TO GDIR^[0].DEOVBLK-1 DO
	BEGIN
	  UNITREAD(GUNIT,A,FBLKSIZE,I);
	  IF SYSCOM^.IORSLT <> INOERROR THEN
	    WRITELN(OUTPUT,'Block ',I,' is bad')
	END
  END (*BADBLOCKS*) ;

  PROCEDURE ZEROVOLUME;
    LABEL 1;
    VAR LDE: DIRENTRY;
  BEGIN
    GUNIT := 0;
    WRITE(OUTPUT,'Zero what unit? ');
    READ(INPUT,GUNIT);
    IF NOT EOLN(INPUT) THEN WRITELN(OUTPUT);
    IF (GUNIT <= 0) OR (GUNIT > MAXUNIT) THEN
      BEGIN
	WRITE(OUTPUT,'Illegal unit #');
	GOTO 1
      END;
    IF NOT UNITABLE[GUNIT].UISBLKD THEN
      BEGIN
	WRITE(OUTPUT,'Unit cannot be zeroed');
	GOTO 1
      END;
    WRITE(OUTPUT,'New volume name (<CR> to escape)? ');
    READLN(INPUT,GVID);
    IF LENGTH(GVID) = 0 THEN GOTO 1;
    WITH LDE DO
      BEGIN
	DFIRSTBLK := 0; DLASTBLK := 6;
	DFKIND := UNTYPEDFILE; DVID := GVID;
	DEOVBLK := -1; DNUMFILES := 0;
	WRITE(OUTPUT,'Number of blocks on volume? ');
	READ(INPUT,DEOVBLK);
	IF NOT EOLN(INPUT) THEN WRITELN(OUTPUT);
	IF DEOVBLK <= 0 THEN
	  BEGIN
	    WRITE(OUTPUT,'Illegal number of blocks');
	    GOTO 1
	  END;
	UNITWRITE(GUNIT,LDE,SIZEOF(LDE),DIRBLK);
	WRITE(OUTPUT,GVID,': zeroed')
      END;
1:
  END (*ZEROVOLUME*) ;

  PROCEDURE DATESET;
    LABEL 1;
    VAR MONINDX,DAYNUM,YEARNUM,I: INTEGER;
	OK: BOOLEAN; CH: CHAR;
	DELIMS: SET OF ' '..'/';

    FUNCTION EATSPACES: BOOLEAN;
      VAR DONE: BOOLEAN;
    BEGIN
      IF LENGTH(GS) > 0 THEN
	REPEAT
	  DONE := GS[1] <> ' ';
	  IF NOT DONE THEN DELETE(GS,1,1)
	UNTIL DONE OR (LENGTH(GS) = 0);
      EATSPACES := LENGTH(GS) = 0
    END (*EATSPACES*) ;

  BEGIN (*DATESET*)
    DELIMS := [' ','-','/'];
    PL := 'DATESET:  <1..31>-<JAN..DEC>-<00..99>  OR <CR>';
    PROMPT; WRITELN(OUTPUT);
    WITH THEDATE DO
      IF MONTH = 0 THEN WRITELN(OUTPUT,'No current date')
      ELSE
	WRITELN(OUTPUT,'Today is ',DAY:2,'-',MONTHS[MONTH],'-',YEAR:2);
    WRITE(OUTPUT,'New date? '); READLN(INPUT,GS);
    IF EATSPACES THEN EXIT(DATESET);
    DAYNUM := 0;
    REPEAT
      OK := GS[1] IN ['0'..'9'];
      IF OK THEN
	BEGIN
	  DAYNUM := DAYNUM*10+ORD(GS[1])-ORD('0');
	  OK := DAYNUM <= 9; DELETE(GS,1,1)
	END
    UNTIL (LENGTH(GS) = 0) OR NOT OK;
    IF (DAYNUM < 1) OR (DAYNUM > 31) THEN GOTO 1;
    IF EATSPACES THEN GOTO 1;
    IF NOT (GS[1] IN DELIMS) THEN GOTO 1;
    DELETE(GS,1,1);
    IF EATSPACES OR (LENGTH(GS) < 3) THEN GOTO 1;
    MONINDX := 12;
    FOR I := 1 TO 3 DO
      BEGIN
	CH := GS[I];
	IF CH >= 'a' THEN
	  CH := CHR(ORD(CH)-ORD('a')+ORD('A'));
	MONTHS[0,I] := CH
      END;
    WHILE MONTHS[MONINDX] <> MONTHS[0] DO
      MONINDX := MONINDX-1;
    IF MONINDX = 0 THEN GOTO 1;
    DELETE(GS,1,3);
    IF EATSPACES THEN GOTO 1;
    IF NOT (GS[1] IN DELIMS) THEN GOTO 1;
    DELETE(GS,1,1);
    IF EATSPACES THEN GOTO 1;
    YEARNUM := 0;
    REPEAT
      OK := GS[1] IN ['0'..'9'];
      IF OK THEN
	BEGIN
	  YEARNUM := YEARNUM*10+ORD(GS[1])-ORD('0');
	  OK := YEARNUM <= 999; DELETE(GS,1,1)
	END
    UNTIL (LENGTH(GS) = 0) OR NOT OK;
    IF LENGTH(GS) > 0 THEN GOTO 1;
    WITH THEDATE DO
      BEGIN
	YEAR := YEARNUM MOD 100; MONTH := MONINDX; DAY := DAYNUM;
	WRITE(OUTPUT,'New date is ',DAY:2,'-',MONTHS[MONTH],'-',YEAR:2)
      END;
    IF FALSE THEN
1:    WRITE(OUTPUT,'Illegal date specification');
  END (* DATESET *) ;
  
  PROCEDURE XBLOCKS;
    LABEL 1;
    VAR LINX: DIRRANGE; CONFLICT: BOOLEAN;
	FIRSTBLK,LASTBLK,MAXBLK,MINBLK,LBLK,I: INTEGER;
	LDE: DIRENTRY; A,B: ARRAY [0..255] OF INTEGER;
  BEGIN
    GS := 'Examine blocks of what volume? ';
    IF GETVOLUME(TRUE) THEN
      BEGIN CONFLICT := FALSE;
	MINBLK := 32767; MAXBLK := -1;
	FIRSTBLK := 0; LASTBLK := 0;
	WRITE(OUTPUT,'What block number-range? ');
	READ(INPUT,FIRSTBLK);
	IF EOLN(INPUT) THEN LASTBLK := FIRSTBLK
	ELSE
	  BEGIN READ(INPUT,LASTBLK);
	    IF NOT EOLN(INPUT) THEN WRITELN(OUTPUT);
	    IF LASTBLK < 0 THEN LASTBLK := ABS(LASTBLK);
	    IF LASTBLK < FIRSTBLK THEN
	      BEGIN I := FIRSTBLK; FIRSTBLK := LASTBLK; LASTBLK := I END
	  END;
	IF FIRSTBLK < GDIR^[0].DLASTBLK THEN
	  BEGIN
	    WRITE(OUTPUT,'You want to risk the directory? ');
	    IF GETCHAR(TRUE) <> 'Y' THEN GOTO 1;
	    WRITELN(OUTPUT)
	  END;
	FOR LINX := 1 TO GDIR^[0].DNUMFILES DO
	  WITH GDIR^[LINX] DO
	    IF (FIRSTBLK < DLASTBLK) AND
		(LASTBLK >= DFIRSTBLK) THEN
	      BEGIN
		IF NOT CONFLICT THEN
		  BEGIN CONFLICT := TRUE;
		    WRITELN(OUTPUT,'File(s) endangered:')
		  END;
		WRITELN(OUTPUT,DTID,' ':TIDLENG-LENGTH(DTID)+1,
			DFIRSTBLK:6,DLASTBLK:6)
	      END;
	IF CONFLICT THEN
	  BEGIN
	    WRITE(OUTPUT,'Do you want to risk them? ');
	    IF GETCHAR(TRUE) <> 'Y' THEN GOTO 1;
	    WRITELN(OUTPUT)
	  END;
	FOR LBLK := FIRSTBLK TO LASTBLK DO
	  BEGIN WRITE(OUTPUT,'Block ',LBLK);
	    UNITREAD(GUNIT,A,FBLKSIZE,LBLK);
	    B := A;
	    UNITWRITE(GUNIT,A,FBLKSIZE,LBLK);
	    IF IORESULT = 0 THEN
	      UNITREAD(GUNIT,B,FBLKSIZE,LBLK);
	    IF (IORESULT = 0) AND (A = B) THEN
	      WRITELN(OUTPUT,' may be recoverable')
	    ELSE
	      BEGIN
		WRITELN(OUTPUT,' is not recoverable');
		IF LBLK < MINBLK THEN MINBLK := LBLK;
		IF LBLK > MAXBLK THEN MAXBLK := LBLK
	      END
	  END;
	IF MAXBLK < 0 THEN GOTO 1;
	IF MINBLK = MAXBLK THEN
	  WRITE(OUTPUT,'Block ',MINBLK,' has a hard error')
	ELSE
	  WRITE(OUTPUT,'Blocks ',MINBLK,' through ',MAXBLK,
			' have hard errors');
	WRITELN(OUTPUT);
	WRITE(OUTPUT,'Mark as bad');
	IF CONFLICT THEN
	  WRITE(OUTPUT,' (may remove files!)');
	WRITE(OUTPUT,'? ');
	IF GETCHAR(TRUE) <> 'Y' THEN GOTO 1;
	WRITELN(OUTPUT);
	IF CONFLICT THEN
	  BEGIN LINX := 1;  (*ZAP CONFLICTS*)
	    WHILE LINX <= GDIR^[0].DNUMFILES DO
	      WITH GDIR^[LINX] DO
		IF (MINBLK < DLASTBLK) AND
		    (MAXBLK >= DFIRSTBLK) THEN
		  DELENTRY(LINX,GDIR)
		ELSE LINX := LINX+1
	  END;
	IF GDIR^[0].DNUMFILES = MAXDIR THEN
	  BEGIN
	    WRITE(OUTPUT,'No room in directory');
	    GOTO 1
	  END;
	WITH LDE DO
	  BEGIN
	    DFIRSTBLK := MINBLK; DLASTBLK := MAXBLK+1;
	    DFKIND := XDSKFILE; DLASTBYTE := FBLKSIZE;
	    DACCESS := THEDATE; DTID := 'BAD.xxxxx.BAD';
	    FIRSTBLK := MINBLK;
	    FOR I := 4 DOWNTO 0 DO
	      BEGIN
		DTID[9-I] := CHR(FIRSTBLK DIV IPOT[I] + ORD('0'));
		FIRSTBLK := FIRSTBLK MOD IPOT[I]
	      END
	  END;
	LINX := GDIR^[0].DNUMFILES;
	WHILE MINBLK < GDIR^[LINX].DLASTBLK DO
	  LINX := LINX-1;
	INSENTRY(LDE,LINX+1,GDIR);
	WRITEDIR(GUNIT,GDIR);
	WRITE(OUTPUT,LDE.DTID,' marked')
      END;
1:
  END (*XBLOCKS*) ;

  PROCEDURE KRUNCH;
    LABEL 1;
    VAR LINX: DIRRANGE; NBLOCKS,DESTBLK: INTEGER;
	RELBLOCK,CHUNKSIZE,AINX,LBLOCK: INTEGER;
	REBOOT: BOOLEAN;
  BEGIN
    GS := 'Crunch what volume? ';
    IF GETVOLUME(TRUE) THEN
      BEGIN
	WRITE(OUTPUT,'Are you sure you want to crunch ',GVID,': ? ');
	IF GETCHAR(TRUE) <> 'Y' THEN GOTO 1;
	WRITELN(OUTPUT);
	SYSCOM^.MISCINFO.NOBREAK := TRUE;
	FOR LINX := 1 TO GDIR^[0].DNUMFILES DO
	  WITH GDIR^[LINX] DO
	    IF (DFKIND <> XDSKFILE) AND
		(DFIRSTBLK > GDIR^[LINX-1].DLASTBLK) THEN
	      BEGIN
		WRITELN(OUTPUT,'Moving ',DTID);
		NBLOCKS := DLASTBLK-DFIRSTBLK;
		DESTBLK := GDIR^[LINX-1].DLASTBLK;
		RELBLOCK := 0;
		REPEAT
		  CHUNKSIZE := NBLOCKS-RELBLOCK;
		  IF CHUNKSIZE > GBUFBLKS THEN CHUNKSIZE := GBUFBLKS;
		  IF CHUNKSIZE > 0 THEN
		    BEGIN AINX := 0;
		      FOR LBLOCK := DFIRSTBLK+RELBLOCK TO
					DFIRSTBLK+RELBLOCK+CHUNKSIZE-1 DO
			BEGIN
			  UNITREAD(GUNIT,GBUF^[AINX],FBLKSIZE,LBLOCK);
			  IF IORESULT <> 0 THEN
			    WRITELN(OUTPUT,'Read error, rel ',
				LBLOCK-DFIRSTBLK,', abs ',LBLOCK);
			  AINX := AINX+FBLKSIZE
			END;
		      AINX := 0;
		      FOR LBLOCK := DESTBLK+RELBLOCK TO
					DESTBLK+RELBLOCK+CHUNKSIZE-1 DO
			BEGIN
			  UNITWRITE(GUNIT,GBUF^[AINX],FBLKSIZE,LBLOCK);
			  IF IORESULT <> 0 THEN
			    WRITELN(OUTPUT,'Write error, rel ',
				LBLOCK-DESTBLK,', abs ',LBLOCK);
			  AINX := AINX+FBLKSIZE
			END;
		      RELBLOCK := RELBLOCK+CHUNKSIZE
		    END
		UNTIL CHUNKSIZE = 0;
		DFIRSTBLK := DESTBLK;
		DLASTBLK := DESTBLK+NBLOCKS
	      END;
	WRITEDIR(GUNIT,GDIR);
	WRITELN(OUTPUT,GVID,': crunched');
	REBOOT := GVID = SYVID;
	IF NOT REBOOT THEN
	  WITH USERINFO DO
	    IF GOTSYM THEN
	      REBOOT := SYMVID = GVID
	    ELSE
	      IF GOTCODE THEN
		REBOOT := CODEVID = GVID;
	IF REBOOT THEN
	  BEGIN
	    WRITELN(OUTPUT,'Please bootload');
	    REPEAT UNTIL FALSE
	  END;
	SYSCOM^.MISCINFO.NOBREAK := FALSE
      END;
1:
  END (*KRUNCH*) ;

BEGIN (*FILEHANDLER*)
  FILERINIT;
  REPEAT
    PL :=
'Filer: G(et, S(ave, W(hat, N(ew, L(dir, R(em, C(hng, T(rans, D(ate, Q(uit';
    PROMPT; GCH := GETCHAR(BADCOMMAND); CLEARSCREEN;
    BADCOMMAND := NOT (GCH IN  ['G','S','W','N','L','E','C','R','D',
				'T','M','V','B','Z','P','X','K']);
    INSTRING := ''; (*IN CASE OF REMOVE ETC*)
    CASE GCH OF
      'G':  GETWORK;
      'S':  SAVEWORK;
      'W':  WHATWORK;
      'N':  NEWWORK(TRUE);
      'L':  LISTDIR(FALSE);
      'E':  LISTDIR(TRUE);
      'C':  CHANGER;
      'R':  REMOVER;
      'P':  PREFIXER;
      'T':  TRANSFER;
      'M':  MAKEFILE;
      'V':  LISTVOLS;
      'B':  BADBLOCKS;
      'Z':  ZEROVOLUME;
      'X':  XBLOCKS;
      'K':  KRUNCH;
      'D':  DATESET
    END
  UNTIL GCH = 'Q'
END (*FILEHANDLER*) ;

BEGIN END.
